home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1996 #15
/
Monster Media Number 15 (Monster Media)(July 1996).ISO
/
os2
/
lxlt113.zip
/
SOURCES
/
COMMON
/
MISCUTIL.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-05-06
|
27KB
|
906 lines
{$A-,B-,D+,E-,F-,G-,I-,L+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
{$ifDef VirtualPascal}
{$AlignCode-,AlignData-,AlignRec-,G3+,Speed-,Frame-}
{$endif}
Unit miscUtil;
Interface uses use32;
const _ON = true;
_OFF = false;
ioOK = 0;
ioNoSuchFile = 1;
ioNoMemory = 2;
ioReadError = 3;
ioWriteError = 4;
ioCantCreate = 5;
ioBadFormat = 6;
type tArrOfByte = array[0..65500] of Byte;
pArrOfByte = ^tArrOfByte;
tArrOfWord = array[0..32700] of Word;
pArrOfWord = ^tArrOfWord;
tArrOfSmallWord = array[0..32700] of SmallWord;
pArrOfSmallWord = ^tArrOfSmallWord;
tArrOfLong = array[0..16380] of Longint;
pArrOfLong = ^tArrOfLong;
tArrOfPtr = array[0..16380] of Pointer;
pArrOfPtr = ^tArrOfPtr;
tArrOfChar = array[0..65500] of Char;
pArrOfChar = ^tArrOfChar;
pByte = ^Byte;
pWord = ^Word;
pSmallWord = ^SmallWord;
pInteger = ^Integer;
pLong = ^Longint;
pString = ^String;
{ Compare function for QuickSort. Return TRUE if Buff[N1] is 'greater }
{ or _EQUAL_' than Buff[N2]. If it will return simply 'less' or 'greater'}
{ the function will cause a protection failure in the best case. If you }
{ use the QuickSort with CmpFunc, you don`t need to specify element size }
tCmpFunc = Function(var Buff; N1,N2 : Word) : boolean;
{ Procedure which exchanges element N1 with N2 in Buff for QuickSort }
{ Note that N1 and N2 in both cases are zero-based }
tXchgProc = Procedure(var Buff; N1,N2 : Word);
{ Dynamic array object }
tArOfPtr = array[1..1000] of Pointer;
pArOfPtr = ^tArOfPtr;
pDArray = ^TDArray;
tDArray = object
NumItems,
MaxItem : Longint;
Root : pArOfPtr;
{Initialize dynamic array; reserve space for StartVal elements}
Constructor Init(StartVal : Longint);
{Add a variable (or reference to variable) into array}
Procedure AddItem(V : Pointer);
{Delete a variable from array}
Procedure DelItem(No : Longint);
{Return variable number No}
Function GetItem(No : Longint) : Pointer;
{Replace variable number No by V and return old pointer value}
Function RplItem(No : Longint; V : Pointer) : Pointer;
{Exchange items N1 & N2}
Procedure XchgItems(N1,N2 : Longint);
{Clear array}
Procedure Clear;
{Destroy array object}
Destructor Done;
end;
{ Dynamic string [de]allocation routines }
Function NewStr(const S : String) : pString;
Procedure DisposeStr(P : PString);
{ Quick sort routine. Element size must be one of 1,2,4 if cmpFunc is }
{ not provided (is nil) - the array will be sorted in usual way (i.e. }
{ from minimal to maximal value. If you use cmpFunc it`s also in your }
{ responsability to supply a valid xchgProc pointer. }
{ NOTE THAT BYTES, WORDS AND DWORDS WILL BE TREATED AS UNSIGNED VALUE }
{$ifDef use32}
Procedure QuickSort(var Buff; First,Last : Word; ElementSize : Byte;
cmpFunc : tCmpFunc; xchgProc : tXchgProc);
{$endIf}
{ Bit-manipulation routines }
Function bitTest(var bitArray; BitNo : Word) : boolean;
Procedure bitSet(var bitArray; BitNo : Word);
Procedure bitReset(var bitArray; BitNo : Word);
{Bit scan forward/reverse functions; return 255 if no set bits in A}
Function BitSF(A : Longint) : Byte;
Function BitSR(A : Longint) : Byte;
{ Min/max functions }
Function minL(A,B : Longint) : Longint;
Function maxL(A,B : Longint) : Longint;
{ The same as System.Move but address always increments (i.e. CLD) }
{ and uses bytes (does not optimize transfer by dwords/words/bytes) }
{ Use it ONLY when there is no possibility of overlapping A & B }
Procedure linearMove(var A,B; Size : Word);
{ Compare two strings; return 0 if equal; positive if A>B and negative if A<B }
Function MemCmp(var A,B; Size : Word) : Shortint;
{ Exchange bytes, words, double words and vars of any size }
Procedure XchgB(var A,B);
Procedure XchgW(var A,B);
Procedure XchgL(var A,B);
Procedure Xchg(var A,B; Size : Word);
{ Search buffer Buff of length BuffLen for a Target of given length TargetLen }
Function Search(var Buff; BuffLen : Word; var Target; TargetLen : Word) : Word;
{ Return interval in minutes between two events }
Function TimeInterval(sYear,sMonth,sDay,sHour,sMin,
fYear,fMonth,fDay,fHour,fMin : Word) : Longint;
{$ifDef use32}
Function bTicker : Byte;
Function wTicker : Word;
Function lTicker : Longint;
{$else use32}
Function bTicker : Byte;
InLine( $8E/$06/seg0040/ { mov es,seg0040 }
$26/$A0/$6C/$00); { mov ax,es:[6Ch] }
Function wTicker : Word;
InLine( $8E/$06/seg0040/ { mov es,seg0040 }
$26/$A1/$6C/$00); { mov ax,es:[6Ch] }
Function lTicker : Longint;
InLine( $8E/$06/seg0040/ { mov es,seg0040 }
$26/$A1/$6C/$00/ { mov ax,es:[6Ch] }
$26/$8B/$16/$6E/$00);{mov dx,es:[6Eh] }
{$endIf use32}
Implementation
{$ifDef os2}
uses os2base;
{$endIf}
constructor tDarray.Init;
begin
GetMem(Root, StartVal * 4);
NumItems := 0;
MaxItem := StartVal;
end;
procedure tDarray.AddItem;
var p : Pointer;
begin
Inc(numItems);
if numItems > maxItem
then begin
Inc(maxItem, 16); GetMem(p, maxItem * sizeOf(Pointer));
Move(Root^, p^, pred(numItems) * sizeOf(Pointer));
FreeMem(Root,(maxItem - 16) * sizeOf(Pointer)); Root := p;
end;
Root^[numItems] := V;
end;
procedure tDarray.DelItem;
var p : Pointer;
begin
if (No > NumItems) or (NumItems = 0) then Exit;
Move(Root^[No + 1], Root^[No], (NumItems-No) * sizeOf(Pointer));
Dec(NumItems);
if NumItems < MaxItem - 16
then begin
Dec(MaxItem, 16); GetMem(p, MaxItem * sizeOf(Pointer));
Move(Root^, p^, NumItems * sizeOf(Pointer));
FreeMem(Root, (MaxItem + 16) * sizeOf(Pointer)); Root := p;
end;
end;
function tDarray.GetItem;
begin
if (No > 0) and (No <= NumItems)
then GetItem := Root^[No]
else GetItem := NIL;
end;
Function tDarray.RplItem;
begin
XchgL(Root^[No], V); RplItem := V;
end;
Procedure tDarray.XchgItems(N1,N2 : Longint);
begin
if (N1 > 0) and (N2 > 0) and (N1 <= NumItems) and (N2 <= NumItems)
then XchgL(Root^[N1], Root^[N2]);
end;
Procedure tDarray.Clear;
begin
if NumItems <> 0
then begin
FreeMem(Root, MaxItem * sizeOf(Pointer));
GetMem(Root, 16 * sizeOf(Pointer)); NumItems := 0; MaxItem := 16;
end;
end;
destructor tDarray.Done;
begin
FreeMem(Root, MaxItem * sizeOf(Pointer));
end;
Function NewStr;
var P : PString;
begin
if S = ''
then P := nil
else begin
GetMem(P, succ(length(S)));
if P <> nil then P^ := S;
end;
NewStr := P;
end;
Procedure DisposeStr;
begin
if P <> NIL then FreeMem(p, succ(length(p^)));
end;
{$ifDef VirtualPascal ██████ Implementation specific for Virtual Pascal █████}
{$frame+,uses ebx,edi,esi}
Procedure QuickSort; assembler;
asm mov eax,First
cmp eax,Last
jge @@done
push eax
push Last
push offset @@done
cmp cmpFunc,0
jne @@qsAny
mov al,ElementSize
cmp al,1
je @@qsByte
cmp al,2
je @@qsWord
cmp al,4
je @@qsDWord {For maximal speed}
jmp @@done3d
{*** Sort Buff as bytes ***}
@@qsByte: mov esi,Buff
mov edi,esi
mov eax,[esp+8] {First}
mov ecx,eax
add esi,eax
mov eax,[esp+4] {Last}
add ecx,eax
shr ecx,1
mov bl,[edi+ecx] {BL = Buff[(first+last)/2]}
add edi,eax
@@repeat1b: dec esi
@@loop1b: inc esi
cmp bl,[esi]
ja @@loop1b
inc edi
@@loop2b: dec edi
cmp bl,[edi]
jb @@loop2b
cmp esi,edi
ja @@done2b
je @@done1b
mov al,[esi]
xchg al,[edi]
mov [esi],al
inc esi
dec edi
jmp @@repeat1b
@@done1b: inc esi
dec edi
@@done2b: mov eax,[esp+8]
sub edi,Buff
jc @@skip1b
cmp eax,edi
jae @@skip1b
push esi
push eax
push edi
call @@qsByte
pop esi
@@skip1b: sub esi,Buff
jc @@skip2b
mov eax,[esp+4]
cmp esi,eax
jae @@skip2b
push esi
push eax
call @@qsByte
@@skip2b: ret 8
{*** Sort Buff as words ***}
@@qsWord: mov esi,Buff
mov edi,esi
mov eax,[esp+8] {First}
mov ecx,eax
shl eax,1
add esi,eax
mov eax,[esp+4] {Last}
add ecx,eax
shr ecx,1
mov bx,[edi+ecx*2] {BX = Buff[(first+last)/2]}
shl eax,1
add edi,eax
@@repeat1w: sub esi,2
@@loop1w: add esi,2
cmp bx,[esi]
ja @@loop1w
add edi,2
@@loop2w: sub edi,2
cmp bx,[edi]
jb @@loop2w
cmp esi,edi
ja @@done2w
je @@done1w
mov ax,[esi]
xchg ax,[edi]
mov [esi],ax
add esi,2
sub edi,2
jmp @@repeat1w
@@done1w: add esi,2
sub edi,2
@@done2w: mov eax,[esp+8]
sub edi,Buff
jc @@skip1w
shr edi,1
cmp eax,edi
jae @@skip1w
push esi
push eax
push edi
call @@qsWord
pop esi
@@skip1w: sub esi,Buff
jc @@skip2w
shr esi,1
mov eax,[esp+4]
cmp esi,eax
jae @@skip2w
push esi
push eax
call @@qsWord
@@skip2w: ret 8
{*** Sort Buff as dwords ***}
@@qsDWord: mov esi,Buff
mov edi,esi
mov eax,[esp+8] {First}
mov ecx,eax
shl eax,2
add esi,eax
mov eax,[esp+4] {Last}
add ecx,eax
shr ecx,1
mov ebx,[edi+ecx*4] {EBX = Buff[(first+last)/2]}
shl eax,2
add edi,eax
@@repeat1d: sub esi,4
@@loop1d: add esi,4
cmp ebx,[esi]
ja @@loop1d
add edi,4
@@loop2d: sub edi,4
cmp ebx,[edi]
jb @@loop2d
cmp esi,edi
ja @@done2d
je @@done1d
mov eax,[esi]
xchg eax,[edi]
mov [esi],eax
add esi,4
sub edi,4
jmp @@repeat1d
@@done1d: add esi,4
sub edi,4
@@done2d: mov eax,[esp+8]
sub edi,Buff
jc @@skip1d
shr edi,2
cmp eax,edi
jae @@skip1d
push esi
push eax
push edi
call @@qsDWord
pop esi
@@skip1d: sub esi,Buff
jc @@skip2d
shr esi,2
mov eax,[esp+4]
cmp esi,eax
jae @@skip2d
push esi
push eax
call @@qsDWord
@@skip2d: ret 8
{*** Sort Buff as any values ***}
@@qsAny: cmp xchgProc,0
je @@done3d
mov esi,[esp+8] {First}
mov ebx,esi
mov edi,[esp+4] {Last}
add ebx,edi
shr ebx,1 {EBX = (first+last)/2}
@@repeat1a: dec esi
@@loop1a: inc esi
push Buff
push esi
push ebx
call cmpFunc {Assume $SAVES ebx,esi,edi}
test al,al
je @@loop1a
inc edi
@@loop2a: dec edi
push Buff
push ebx
push edi
call cmpFunc {Assume $SAVES esi,edi}
test al,al
je @@loop2a
cmp esi,edi
ja @@done2a
je @@done1a
push Buff
push esi
push edi
call xchgProc
cmp ebx,esi
jne @@xchg1a
mov ebx,edi
jmp @@xchg2a
@@xchg1a: cmp ebx,edi
jne @@xchg2a
mov ebx,esi
@@xchg2a: inc esi
dec edi
jmp @@repeat1a
@@done1a: inc esi
dec edi
@@done2a: mov eax,[esp+8]
test edi,edi
js @@skip1a
cmp eax,edi
jae @@skip1a
push esi
push eax
push edi
call @@qsAny
pop esi
@@skip1a: test esi,esi
js @@skip2a
mov eax,[esp+4]
cmp esi,eax
jae @@skip2a
push esi
push eax
call @@qsAny
@@skip2a: ret 8
@@done3d: add esp,4+4+4
@@done:
end;
{$frame-,uses none}
{$saves ebx,edx,esi,edi}
Function bitTest; assembler;
asm mov eax,bitArray
mov ecx,bitNo
bt [eax],ecx
setc al
end;
Procedure bitSet; assembler;
asm mov eax,bitArray
mov ecx,bitNo
bts [eax],ecx
end;
Procedure bitReset; assembler;
asm mov eax,bitArray
mov ecx,bitNo
btr [eax],ecx
end;
{$saves ebx,esi,edi}
Procedure XchgB(var a,b); assembler;
asm mov ecx,A
mov edx,B
mov al,[ecx]
xchg al,[edx]
mov [ecx],al
end;
Procedure XchgW(var a,b); assembler;
asm mov ecx,A
mov edx,B
mov ax,[ecx]
xchg ax,[edx]
mov [ecx],ax
end;
Procedure XchgL; assembler;
asm mov ecx,A
mov edx,B
mov eax,[ecx]
xchg eax,[edx]
mov [ecx],eax
end;
{$uses ebx}
Procedure Xchg(var A,B; Size : Word); assembler;
asm mov ebx,A
mov edx,B
mov ecx,Size
@@next: mov al,[ebx]
xchg al,[edx]
mov [ebx],al
inc ebx
inc edx
loop @@next
end;
{$uses none}
{$uses esi,edi} {$saves eax,ebx,edx}
Procedure linearMove; assembler;
asm cld
mov esi,A
mov edi,B
mov ecx,Size
rep movsb
end;
{$uses none}
{$saves all}
Function minL; assembler;
asm mov eax,A
cmp eax,B
jl @@ok
mov eax,B
@@ok:
end;
Function maxL; assembler;
asm mov eax,A
cmp eax,B
jg @@ok
mov eax,B
@@ok:
end;
Function BitSF; assembler;
asm mov eax,A
bsf eax,eax
jnz @@ok
dec al
@@ok:
end;
Function BitSR; assembler;
asm mov eax,A
bsr eax,eax
jnz @@ok
dec al
@@ok:
end;
{$uses esi,edi} {$saves ebx,edx,esi,edi}
Function MemCmp; assembler;
asm cld
mov esi,A
mov edi,B
mov ecx,Size
repe cmpsb
lahf
mov al,ah
and al,0C0h {Dirty trick :)}
xor al,040h
end;
{$uses none}
Function Search; assembler;
asm cld
mov edi,Buff
mov ecx,BuffLen
sub ecx,TargetLen
jbe @@notFound
inc ecx
mov esi,Target
mov al,[esi]
@@Scan: repne scasb
jne @@notFound
push ecx
push esi
push edi
dec edi
mov ecx,TargetLen
repe cmpsb
pop edi
pop esi
pop ecx
jne @@Scan
dec edi
sub edi,Buff
mov eax,edi
jmp @@locEx
@@notFound: mov eax,-1
@@locEx:
end;
{$else ███████████ Implementation specific for Borland Pascal 7.0 ███████████}
Procedure bitSet; assembler;
asm les di,bitArray
mov bx,bitNo
cmp test8086,2
jb @@8086
db $26,$0F,$AB,$1D {bts es:[di],bx}
jmp @@locEx
@@8086: mov cl,bl
shr bx,1
shr bx,1
shr bx,1
and cl,7
mov al,00000001b
rol al,cl
or es:[bx+di],al
@@locEx:
end;
Procedure bitReset; assembler;
asm les di,bitArray
mov bx,bitNo
cmp test8086,2
jb @@8086
db $26,$0F,$B3,$1D {btr es:[di],bx}
jmp @@locEx
@@8086: mov cl,bl
shr bx,1
shr bx,1
shr bx,1
and cl,7
mov al,11111110b
rol al,cl
and es:[bx+di],al
@@locEx:
end;
Function bitTest; assembler;
asm les di,bitArray
mov bx,bitNo
cmp test8086,2
jb @@8086
db $26,$0F,$A3,$1D {bt es:[di],bx}
db $0F,$92,$C0 {setc al}
jmp @@locEx
@@8086: mov cl,bl
shr bx,1
shr bx,1
shr bx,1
and cl,7
mov al,00000001b
rol al,cl
test es:[bx+di],al
mov al,0
jz @@locEx
inc al
@@locEx:
end;
Function bitSF; assembler;
asm db $66;mov ax,A.word
db $66,$0F,$BC,$C0 {bsf eax,eax}
jnz @@ok
dec al
@@ok:
end;
Function bitSR; assembler;
asm db $66;mov ax,A.word
db $66,$0F,$BD,$C0 {bsr eax,eax}
jnz @@ok
dec al
@@ok:
end;
Function MemCmp; assembler;
asm cld
push ds
lds si,A
les di,B
mov cx,Size
repe cmpsb
pop ds
lahf
mov al,ah
and al,0C0h {Dirty trick :)}
xor al,040h
end;
Function Search; assembler;
asm cld
push ds
les di,Buff
mov cx,BuffLen
sub cx,TargetLen
jbe @@NotFound
inc cx
lds si,Target
mov al,[si]
@@Scan: repne scasb
jne @@NotFound
push cx
push si
push di
dec di
mov cx,TargetLen
repe cmpsb
pop di
pop si
pop cx
jne @@Scan
dec di
sub di,Buff.word
mov ax,di
jmp @@locEx
@@NotFound: mov ax,-1
@@locEx: pop ds
end;
Procedure XchgB(var a,b); assembler;
asm push ds
les di,a
lds si,b
mov al,es:[di]
xchg al,ds:[si]
cld
stosb
pop ds
end;
Procedure XchgW(var a,b); assembler;
asm push ds
les di,a
lds si,b
mov ax,es:[di]
xchg ax,ds:[si]
cld
stosw
pop ds
end;
Procedure XchgL(var a,b); assembler;
asm push ds
les di,a
lds si,b
mov ax,es:[di]
xchg ax,ds:[si]
cld
stosw
mov ax,es:[di]
xchg ax,ds:[si+2]
stosw
pop ds
end;
Procedure Xchg(var A,B; Size : Word); assembler;
asm push ds
lds si,A
les di,B
mov cx,Size
@@1: mov al,ds:[si]
xchg es:[di],al
mov ds:[si],al
inc si
inc di
loop @@1
pop ds
end;
Procedure linearMove; assembler;
asm cld
push ds
lds si,A
les di,B
mov cx,Size
rep movsb
pop ds
end;
Function minL(A,B : Longint) : Longint;
begin
if A <= B then minL := A else minL := B;
end;
Function maxL(A,B : Longint) : Longint;
begin
if A >= B then maxL := A else maxL := B;
end;
{$endIf ███████████████████ end of compiler - specific section █████████████}
Function TimeInterval(sYear,sMonth,sDay,sHour,sMin,
fYear,fMonth,fDay,fHour,fMin : Word) : Longint;
const
daysInMonth : array[1..12] of Byte =
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
var cY,cM,cD,cH,cMin : Word;
tI : Longint;
procedure IncMonth;
begin
Inc(cM);
if cM > 12 then begin cM := 1; Inc(cY); end;
end;
procedure IncDay;
begin
Inc(cD);
if cD > daysInMonth[cM] + byte((cM = 2) and (cY and 3 = 0))
then begin cD := 1; IncMonth; end;
end;
procedure IncHour;
begin
Inc(cH);
if cH > 23 then begin cH := 0; IncDay; end;
end;
procedure IncMin;
begin
Inc(cMin);
if cMin > 59 then begin cMin := 0; IncHour; end;
end;
begin
cY := sYear; cM := sMonth; cD := sDay;
cH := sHour; cMin := sMin; tI := 0;
While (cY <> fYear) or (cM <> fMonth) or (cD <> fDay) or
(cH <> fHour) or (cMin <> fMin) do
begin
if (cY <> fYear) and (cM = 1) and (cD = 1) and (cH = 0) and (cMin = 0)
then begin
Inc(tI, longint(365 + byte(cY and 3 = 0)) * 1440);
Inc(cY);
end
else
if ((cY <> fYear) or (cM <> fMonth)) and (cD = 1) and (cH = 0) and (cMin = 0)
then begin
Inc(tI, longint(daysInMonth[cM] + byte((cM = 2) and (cY and 3 = 0))) * 1440);
IncMonth;
end
else
if ((cY <> fYear) or (cM <> fMonth) or (cD <> fDay)) and (cH = 0) and (cMin = 0)
then begin
Inc(tI, 1440); IncDay;
end
else
if ((cY <> fYear) or (cM <> fMonth) or (cD <> fDay) or (cH <> fHour)) and (cMin = 0)
then begin
Inc(tI, 60); IncHour;
end
else begin
Inc(tI); IncMin;
end;
end;
TimeInterval := tI;
end;
{$ifDef use32}
Function lTicker : Longint;
var L : Longint;
begin
DosQuerySysInfo(qsv_Ms_Count, qsv_Ms_Count, L, SizeOf(L));
lTicker := L;
end;
Function wTicker : Word;
begin
wTicker := lTicker and $FFFF;
end;
Function bTicker : Byte;
begin
bTicker := lTicker and $FF;
end;
{$endIf use32}
end.